Dijkstra's Algorithm/Dijkstramod.bas

Attribute VB_Name = "Dijkstramod"
Option Explicit
'(c)2002 by Louis. Algorithm by Dijkstra.
'
'NOTE: the code of this module was created out of VC sample code
'found on the Internet. This code works, but is not so fast.
'NOTE: this module and the related class module can be used
'as a General Function, you can add it to any kind of target project.
'
'Dijkstra Constants
Public Const DIJKSTRA_NO_CONNECTION = 256& ^ 3&
'DijkstraNodeStruct
Private Type DijkstraNodeStruct
    NodeDistance As Long
    NodePreviousIndex As Long
End Type
'other
Dim DijkstraclsNumber As Long
Dim DijkstraclsMain As Dijkstracls
Dim MsgString As String

Public Sub Dijkstra_FindPath(ByVal NodeNumber As Long, ByRef NodeLinkMatrix() As Long, ByVal NodeStartIndex As Long, ByVal NodeEndIndex As Long, ByRef PathLengthMin As Long, ByRef PathIndexNumber As Long, ByRef PathIndexArray() As Long)
    'on error resume next
    ReDim DijkstraNodeStructArray(1 To NodeNumber) As DijkstraNodeStruct
    Dim NodeIndex As Long
    Dim NodeDistance As Long
    Dim NodePreviousIndex As Long
    Dim NodeCostCurrent As Long
    Dim Temp As Long
    Dim Temp2 As Long
    Dim Tempstr$
    'preset
    '
    'DEBUG
    'For Temp = 1 To NodeNumber
    '    For Temp2 = 1 To NodeNumber
    '        Tempstr$ = CStr(NodeLinkMatrix(Temp, Temp2))
    '        Debug.Print Tempstr$ + String$(16 ‑ Len(Tempstr$), " ");
    '    Next Temp2
    '    Debug.Print
    'Next Temp

    'END OF DEBUG
    '
    Set DijkstraclsMain = Nothing
    '
    For Temp = 1 To NodeNumber
        DijkstraNodeStructArray(Temp).NodeDistance = DIJKSTRA_NO_CONNECTION 'preset
        DijkstraNodeStructArray(Temp).NodePreviousIndex = DIJKSTRA_NO_CONNECTION 'preset
    Next Temp
    '
    DijkstraNodeStructArray(NodeStartIndex).NodeDistance = 0 'preset
    DijkstraNodeStructArray(NodeStartIndex).NodePreviousIndex = DIJKSTRA_NO_CONNECTION 'preset
    '
    'begin
    '
    'Set DijkstraclsMain = New Dijkstracls 'no! must be Nothing (see Dijkstra_Enqueue())
    '
    Call Dijkstra_Enqueue(NodeStartIndex, 0, DIJKSTRA_NO_CONNECTION)
    '
    While (DijkstraclsNumber > 0)
        '
        Call Dijkstra_Dequeue(NodeIndex, NodeDistance, NodePreviousIndex)
        '
        For Temp = 1 To NodeNumber
            '
            NodeCostCurrent = NodeLinkMatrix(NodeIndex, Temp)
            If Not (NodeCostCurrent = DIJKSTRA_NO_CONNECTION) Then
                If ((DijkstraNodeStructArray(Temp).NodeDistance = DIJKSTRA_NO_CONNECTION) Or (DijkstraNodeStructArray(Temp).NodeDistance > (NodeCostCurrent + NodeDistance))) Then
                    DijkstraNodeStructArray(Temp).NodeDistance = NodeDistance + NodeCostCurrent
                    DijkstraNodeStructArray(Temp).NodePreviousIndex = NodeIndex
                    Call Dijkstra_Enqueue(Temp, NodeDistance + NodeCostCurrent, NodeIndex)
                End If
            End If
        Next Temp
    Wend
    'DEBUG
    'MsgString = "" 'reset
    'Call Dijkstra_PrintPath(DijkstraNodeStructArray(), NodeEndIndex)
    'MsgBox MsgString
    'END OF DEBUG
    PathIndexNumber = PathIndexNumber + 1
    If ((PathIndexNumber ‑ 1) Mod 64) = 0 Then
        ReDim Preserve PathIndexArray(1 To PathIndexNumber + 63) As Long
    End If
    PathIndexArray(PathIndexNumber) = NodeEndIndex
    Do
        If DijkstraNodeStructArray(PathIndexArray(PathIndexNumber)).NodePreviousIndex = DIJKSTRA_NO_CONNECTION Then Exit Do
        PathIndexNumber = PathIndexNumber + 1
        If ((PathIndexNumber ‑ 1) Mod 64) = 0 Then
            ReDim Preserve PathIndexArray(1 To PathIndexNumber + 63) As Long
        End If
        PathIndexArray(PathIndexNumber) = DijkstraNodeStructArray(PathIndexArray(PathIndexNumber ‑ 1)).NodePreviousIndex
    Loop
    'swap array (we couldn't assign in right order as only NodePreviousIndex items are known, not next)
    For Temp = 1 To Int(PathIndexNumber / 2)
        Temp2 = PathIndexArray(Temp)
        PathIndexArray(Temp) = PathIndexArray(PathIndexNumber ‑ Temp + 1)
        PathIndexArray(PathIndexNumber ‑ Temp + 1) = Temp2
    Next Temp
    PathLengthMin = DijkstraNodeStructArray(NodeEndIndex).NodeDistance
End Sub

Private Sub Dijkstra_Enqueue(ByVal NodeIndex As Long, ByVal NodeDistance As Long, ByVal NodePreviousIndex As Long)
    'on error resume next
    Dim DijkstraclsNew As New Dijkstracls
    Dim DijkstraclsLast As Dijkstracls
    'preset
    Set DijkstraclsLast = DijkstraclsMain 'IMPORTANT: use DijkstraclsLast, not DijkstraclsMain (for what reason ever, copied from sample, important)
    DijkstraclsNew.NodeIndex = NodeIndex
    DijkstraclsNew.NodeDistance = NodeDistance
    DijkstraclsNew.NodePreviousIndex = NodePreviousIndex
    Set DijkstraclsNew.DijkstraclsNext = Nothing
    'begin
    If (DijkstraclsMain Is Nothing) Then
        Set DijkstraclsMain = DijkstraclsNew
    Else
        While (Not (DijkstraclsLast.DijkstraclsNext Is Nothing))
            Set DijkstraclsLast = DijkstraclsLast.DijkstraclsNext
        Wend
        Set DijkstraclsLast.DijkstraclsNext = DijkstraclsNew
    End If
    DijkstraclsNumber = DijkstraclsNumber + 1&
End Sub

Private Sub Dijkstra_Dequeue(ByRef NodeIndex As Long, ByRef NodeDistance As Long, ByRef NodePreviousIndex As Long)
    'on error resume next
    If Not (DijkstraclsMain Is Nothing) Then
        NodeIndex = DijkstraclsMain.NodeIndex
        NodeDistance = DijkstraclsMain.NodeDistance
        NodePreviousIndex = DijkstraclsMain.NodePreviousIndex
        Set DijkstraclsMain = DijkstraclsMain.DijkstraclsNext
    End If
    DijkstraclsNumber = DijkstraclsNumber ‑ 1&
End Sub

Private Sub Dijkstra_PrintPath(ByRef DijkstraNodeStructArray() As DijkstraNodeStruct, ByVal NodeIndex As Long)
    'on error resume next 'this sub is used for debugging only
    If Not (DijkstraNodeStructArray(NodeIndex).NodePreviousIndex = DIJKSTRA_NO_CONNECTION) Then
        Call Dijkstra_PrintPath(DijkstraNodeStructArray(), DijkstraNodeStructArray(NodeIndex).NodePreviousIndex)
    End If
    'MsgString = MsgString + " " + DijkstraNodeStructArray(NodeIndex).NodeName
End Sub


[END OF FILE]